home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / Marlais 0.5.9-portable sources / function.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  27.8 KB  |  1,068 lines  |  [TEXT/ttxt]
  1. /*
  2.  
  3.    function.c
  4.  
  5.    This software is free software; you can redistribute it and/or
  6.    modify it under the terms of the GNU Library General Public
  7.    License as published by the Free Software Foundation; either
  8.    version 2 of the License, or (at your option) any later version.
  9.  
  10.    This software is distributed in the hope that it will be useful,
  11.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.    Library General Public License for more details.
  14.  
  15.    You should have received a copy of the GNU Library General Public
  16.    License along with this software; if not, write to the Free
  17.    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.    Original copyright notice follows:
  20.  
  21.    Copyright, 1993, Brent Benson.  All Rights Reserved.
  22.    0.4 & 0.5 Revisions Copyright 1994, Joseph N. Wilson.  All Rights Reserved.
  23.  
  24.    Permission to use, copy, and modify this software and its
  25.    documentation is hereby granted only under the following terms and
  26.    conditions.  Both the above copyright notice and this permission
  27.    notice must appear in all copies of the software, derivative works
  28.    or modified version, and both notices must appear in supporting
  29.    documentation.  Users of this software agree to the terms and
  30.    conditions set forth in this notice.
  31.  
  32.  */
  33.  
  34. #include <string.h>
  35.  
  36. #include "function.h"
  37.  
  38. #include "apply.h"
  39. #include "class.h"
  40. #include "env.h"
  41. #include "error.h"
  42. #include "eval.h"
  43. #include "keyword.h"
  44. #include "list.h"
  45. #include "number.h"
  46. #include "prim.h"
  47. #include "symbol.h"
  48. #include "values.h"
  49. #include "vector.h"
  50.  
  51. extern Object x_symbol;
  52.  
  53. /* local function prototypes */
  54.  
  55. static Object generic_function_make (Object arglist);
  56. static Object generic_function_methods (Object gen);
  57. static Object generic_function_mandatory_keywords (Object generic);
  58. static Object function_specializers (Object func);
  59. static Object function_values (Object func);
  60. static Object make_specializers_from_params (Object);
  61. static Object function_specializers_help (Object params);
  62. static Object function_arguments (Object fun);
  63. static Object user_applicable_method_p (Object fun, Object sample_args);
  64. static Object applicable_method_p (Object fun,
  65.                    Object sample_args,
  66.                    int strict_check);
  67. static Object sort_methods (Object methods, Object sample_args);
  68. static int sort_driver (Object *pmeth1, Object *pmeth2);
  69. static int same_specializers (Object s1, Object s2);
  70. static int specializer_compare (Object spec1, Object spec2);
  71. static Object find_method (Object generic, Object spec_list);
  72. static Object remove_method (Object generic, Object method);
  73. static Object debug_name_setter (Object method, Object name);
  74.  
  75. /* primitives */
  76.  
  77. static struct primitive function_prims[] =
  78. {
  79.     {"%add-method", prim_2, add_method},
  80.     {"%generic-function-make", prim_1, generic_function_make},
  81.     {"%generic-function-methods", prim_1, generic_function_methods},
  82.     {"%generic-function-mandatory-keywords", prim_1,
  83.      generic_function_mandatory_keywords},
  84.     {"%function-specializers", prim_1, function_specializers},
  85.     {"%function-values", prim_1, function_values},
  86.     {"%function-arguments", prim_1, function_arguments},
  87.     {"%applicable-method?", prim_1_rest, user_applicable_method_p},
  88.     {"%sorted-applicable-methods", prim_1_rest, sorted_applicable_methods},
  89.     {"%find-method", prim_2, find_method},
  90.     {"%remove-method", prim_2, remove_method},
  91.     {"%debug-name-setter", prim_2, debug_name_setter},
  92. };
  93.  
  94. /* function definitions */
  95.  
  96.  
  97. void
  98. init_function_prims (void)
  99. {
  100.     int num;
  101.     Object obj_sym, t_sym;
  102.  
  103.     num = sizeof (function_prims) / sizeof (struct primitive);
  104.  
  105.     init_prims (num, function_prims);
  106. }
  107.  
  108. static void
  109. keyword_list_insert (Object *list, Object key_binding)
  110. {
  111.     Object *tmp_ptr;
  112.     int compare;
  113.     char *key_name;
  114.  
  115.     key_name = SYMBOLNAME (CAR (key_binding));
  116.     /* Search for insert point, then break */
  117.  
  118.     tmp_ptr = list;
  119.     while (PAIRP (*tmp_ptr)) {
  120.     compare = strcmp (key_name, SYMBOLNAME (CAR (CAR (*tmp_ptr))));
  121.     if (compare < 0) {
  122.         tmp_ptr = &CDR (*tmp_ptr);
  123.     } else if (compare > 0) {
  124.         break;
  125.     } else {
  126.         error ("keyword specified twice", CAR (key_binding),
  127.            CAR (CAR (*tmp_ptr)), NULL);
  128.         return;
  129.     }
  130.     }
  131.     *tmp_ptr = cons (key_binding, *tmp_ptr);
  132. }
  133.  
  134. static void
  135. parse_generic_function_parameters (Object gf_obj, Object params)
  136. {
  137.     Object entry, *tmp_ptr, result_type;
  138.  
  139.     tmp_ptr = &GFREQPARAMS (gf_obj);
  140.     *tmp_ptr = make_empty_list ();
  141.  
  142.     /* first get required params */
  143.     while (PAIRP (params)) {    /* CONTAINS BREAK! */
  144.     entry = CAR (params);
  145.     if (entry == hash_rest_symbol || entry == key_symbol ||
  146.         entry == hash_values_symbol) {
  147.         break;
  148.     }
  149.     if (PAIRP (entry)) {
  150.         (*tmp_ptr) = cons (listem (CAR (entry),
  151.                        eval (SECOND (entry)),
  152.                        NULL),
  153.                    make_empty_list ());
  154.     } else {
  155.         *tmp_ptr = cons (listem (entry, object_class, NULL),
  156.                  make_empty_list ());
  157.     }
  158.     tmp_ptr = &CDR (*tmp_ptr);
  159.     params = CDR (params);
  160.     }
  161.  
  162.     /* next look for rest parameter */
  163.     if (PAIRP (params) && CAR (params) == hash_rest_symbol) {
  164.     params = CDR (params);
  165.     if (PAIRP (params)) {
  166.         GFRESTPARAM (gf_obj) = CAR (params);
  167.         params = CDR (params);
  168.     } else {
  169.         error ("generic function #rest designator not followed by a parameter", NULL);
  170.     }
  171.     } else {
  172.     GFRESTPARAM (gf_obj) = NULL;
  173.     }
  174.     /* next look for key parameters */
  175.     GFKEYPARAMS (gf_obj) = make_empty_list ();
  176.     if (PAIRP (params) && CAR (params) == key_symbol) {
  177.     GFPROPS (gf_obj) |= GFKEYSMASK;
  178.     params = CDR (params);
  179.     while (PAIRP (params)) {    /* CONTAINS BREAK! */
  180.         entry = CAR (params);
  181.         if (entry == allkeys_symbol) {
  182.         break;
  183.         }
  184.         /* get a keyword-parameter */
  185.         if (SYMBOLP (entry)) {
  186.         keyword_list_insert (&GFKEYPARAMS (gf_obj),
  187.                      listem (symbol_to_keyword (entry),
  188.                          entry,
  189.                          false_object,
  190.                          NULL));
  191.         } else if (PAIRP (entry) && SYMBOLP (CAR (entry)) &&
  192.                list_length (entry) == 2) {
  193.         keyword_list_insert (&GFKEYPARAMS (gf_obj),
  194.                      listem (symbol_to_keyword (CAR (entry)),
  195.                          CAR (entry),
  196.                          SECOND (entry),
  197.                          NULL));
  198.         } else if (PAIRP (entry) && KEYWORDP (CAR (entry)) &&
  199.                list_length (entry) == 3) {
  200.         keyword_list_insert (&GFKEYPARAMS (gf_obj), entry);
  201.         }
  202.         params = CDR (params);
  203.     }
  204.     if (PAIRP (params) && CAR (params) == allkeys_symbol) {
  205.         GFPROPS (gf_obj) |= GFALLKEYSMASK;
  206.         params = CDR (params);
  207.         if (PAIRP (params) && CAR (params) != hash_values_symbol) {
  208.         error ("parameters follow #all-keys", params);
  209.         }
  210.     }
  211.     }
  212.     /* now get return value types */
  213.     if (PAIRP (params) && CAR (params) == hash_values_symbol) {
  214.     params = CDR (params);
  215.     GFRESTVALUES (gf_obj) = NULL;
  216.     tmp_ptr = &GFREQVALUES (gf_obj);
  217.     *tmp_ptr = make_empty_list ();
  218.  
  219.     /* first get required return values */
  220.     /* first get required return values */
  221.     while (PAIRP (params)) {    /* CONTAINS BREAK! */
  222.         entry = CAR (params);
  223.         if (entry == hash_rest_symbol) {
  224.         break;
  225.         }
  226.         if (PAIRP (entry)) {
  227.         result_type = eval (SECOND (entry));
  228.         } else {
  229.         result_type = object_class;
  230.         }
  231.  
  232.         (*tmp_ptr) = cons (result_type, make_empty_list ());
  233.         tmp_ptr = &CDR (*tmp_ptr);
  234.         params = CDR (params);
  235.     }
  236.  
  237.     /* next look for rest parameter */
  238.     if (PAIRP (params) && CAR (params) == hash_rest_symbol) {
  239.         params = CDR (params);
  240.         if (PAIRP (params)) {
  241.         if (PAIRP (CAR (params))) {
  242.             GFRESTVALUES (gf_obj) = eval (SECOND (CAR (params)));
  243.         } else {
  244.             GFRESTVALUES (gf_obj) = object_class;
  245.         }
  246.         params = CDR (params);
  247.         } else {
  248.         error ("generic function #rest designator not followed by a parameter", NULL);
  249.         }
  250.     }
  251.     } else {            /* no values specified */
  252.     GFREQVALUES (gf_obj) = make_empty_list ();
  253.     GFRESTVALUES (gf_obj) = object_class;
  254.     }
  255.  
  256.     if (PAIRP (params)) {
  257.     error ("objects encountered after parameter list", params, NULL);
  258.     }
  259.     if (trace_functions) {
  260.     warning ("Got GF", GFNAME (gf_obj), NULL);
  261.     warning (" Required parameters", GFREQPARAMS (gf_obj), NULL);
  262.     warning (" Rest parameter", GFRESTPARAM (gf_obj), NULL);
  263.     if (GFHASKEYS (gf_obj)) {
  264.         warning (" Has keys", NULL);
  265.         warning (" Key parameters", GFKEYPARAMS (gf_obj), NULL);
  266.     }
  267.     if (GFALLKEYS (gf_obj)) {
  268.         warning (" All Keys specified", NULL);
  269.     }
  270.     warning (" Required return values", GFREQVALUES (gf_obj), NULL);
  271.     warning (" Rest return value type", GFRESTVALUES (gf_obj), NULL);
  272.     }
  273. }
  274.  
  275. Object
  276. make_generic_function (Object name, Object params, Object methods)
  277. {
  278.     Object obj;
  279.  
  280.     obj = allocate_object (sizeof (struct generic_function));
  281.  
  282.     GFTYPE (obj) = GenericFunction;
  283.     GFNAME (obj) = name;
  284.     parse_generic_function_parameters (obj, params);
  285.     GFMETHODS (obj) = methods;
  286.     return (obj);
  287. }
  288.  
  289. static void
  290. parse_method_parameters (Object meth_obj, Object params)
  291. {
  292.     Object entry, *tmp_ptr, result_type;
  293.  
  294.     tmp_ptr = &METHREQPARAMS (meth_obj);
  295.     *tmp_ptr = make_empty_list ();
  296.  
  297.     /* first get required params */
  298.     while (PAIRP (params)) {    /* CONTAINS BREAK! */
  299.     entry = CAR (params);
  300.     if (entry == hash_rest_symbol || entry == key_symbol ||
  301.         entry == hash_values_symbol || entry == next_symbol) {
  302.         break;
  303.     }
  304.     if (PAIRP (entry)) {
  305.         (*tmp_ptr) = cons (listem (CAR (entry),
  306.                        eval (SECOND (entry)),
  307.                        NULL),
  308.                    make_empty_list ());
  309.     } else {
  310.         *tmp_ptr = cons (listem (entry, object_class, NULL),
  311.                  make_empty_list ());
  312.     }
  313.     tmp_ptr = &CDR (*tmp_ptr);
  314.     params = CDR (params);
  315.     }
  316.  
  317.     /* look for next-method parameter */
  318.     if (PAIRP (params) && CAR (params) == next_symbol) {
  319.     params = CDR (params);
  320.     if (PAIRP (params)) {
  321.         METHNEXTMETH (meth_obj) = CAR (params);
  322.         params = CDR (params);
  323.     } else {
  324.         error ("generic function #next designator not followed by a parameter", NULL);
  325.     }
  326.     } else {
  327.     METHNEXTMETH (meth_obj) = next_method_symbol;
  328.     }
  329.  
  330.     /* next look for rest parameter */
  331.     if (PAIRP (params) && CAR (params) == hash_rest_symbol) {
  332.     params = CDR (params);
  333.     if (PAIRP (params)) {
  334.         METHRESTPARAM (meth_obj) = CAR (params);
  335.         params = CDR (params);
  336.     } else {
  337.         error ("generic function #rest designator not followed by a parameter", NULL);
  338.     }
  339.     } else {
  340.     METHRESTPARAM (meth_obj) = NULL;
  341.     }
  342.  
  343.     /* next look for key parameters */
  344.     METHKEYPARAMS (meth_obj) = make_empty_list ();
  345.     if (PAIRP (params) && CAR (params) == key_symbol) {
  346.     params = CDR (params);
  347.     while (PAIRP (params)) {    /* CONTAINS BREAK! */
  348.         entry = CAR (params);
  349.         if (entry == allkeys_symbol) {
  350.         break;
  351.         }
  352.         /* get a keyword-parameter pair */
  353.         if (SYMBOLP (entry)) {
  354.         keyword_list_insert (&METHKEYPARAMS (meth_obj),
  355.                      listem (symbol_to_keyword (entry),
  356.                          entry,
  357.                          false_object,
  358.                          NULL));
  359.         } else if (PAIRP (entry) && SYMBOLP (CAR (entry)) &&
  360.                list_length (entry) == 2) {
  361.         keyword_list_insert (&METHKEYPARAMS (meth_obj),
  362.                      listem (symbol_to_keyword (CAR (entry)),
  363.                          CAR (entry),
  364.                          SECOND (entry),
  365.                          NULL));
  366.         } else if (PAIRP (entry) && KEYWORDP (CAR (entry)) &&
  367.                list_length (entry) == 3) {
  368.         keyword_list_insert (&METHKEYPARAMS (meth_obj), entry);
  369.         }
  370.         params = CDR (params);
  371.     }
  372.     }
  373.     if (PAIRP (params) && CAR (params) == allkeys_symbol) {
  374.     METHPROPS (meth_obj) |= METHALLKEYSMASK;
  375.     params = CDR (params);
  376.     if (PAIRP (params) && CAR (params) != hash_values_symbol) {
  377.         error ("parameters follow #all-keys", params);
  378.     }
  379.     }
  380.     /* now get return value types */
  381.     if (PAIRP (params) && CAR (params) == hash_values_symbol) {
  382.     params = CDR (params);
  383.     METHRESTVALUES (meth_obj) = NULL;
  384.     tmp_ptr = &METHREQVALUES (meth_obj);
  385.     *tmp_ptr = make_empty_list ();
  386.  
  387.     /* first get required return values */
  388.     while (PAIRP (params)) {    /* CONTAINS BREAK! */
  389.         entry = CAR (params);
  390.         if (entry == hash_rest_symbol) {
  391.         break;
  392.         }
  393.         if (PAIRP (entry)) {
  394.         result_type = eval (SECOND (entry));
  395.         } else {
  396.         result_type = object_class;
  397.         }
  398.  
  399.         (*tmp_ptr) = cons (result_type, make_empty_list ());
  400.         tmp_ptr = &CDR (*tmp_ptr);
  401.         params = CDR (params);
  402.     }
  403.  
  404.     /* next look for rest parameter */
  405.     if (PAIRP (params) && CAR (params) == hash_rest_symbol) {
  406.         params = CDR (params);
  407.         if (PAIRP (params)) {    /* need structure check */
  408.         if (PAIRP (CAR (params))) {
  409.             METHRESTVALUES (meth_obj) = eval (SECOND (CAR (params)));
  410.         } else {
  411.             METHRESTVALUES (meth_obj) = object_class;
  412.         }
  413.         params = CDR (params);
  414.         } else {
  415.         error ("function #rest designator not followed by a parameter", NULL);
  416.         }
  417.     }
  418.     } else {
  419.     METHREQVALUES (meth_obj) = make_empty_list ();
  420.     METHRESTVALUES (meth_obj) = object_class;
  421.     }
  422.  
  423.     if (PAIRP (params)) {
  424.     error ("objects encountered after parameter list", params, NULL);
  425.     }
  426.     if (trace_functions) {
  427.     warning ("Got Method", METHNAME (meth_obj), NULL);
  428.     warning (" Required parameters", METHREQPARAMS (meth_obj), NULL);
  429.     warning (" Rest parameter", METHRESTPARAM (meth_obj), NULL);
  430.     warning (" Key parameters", METHKEYPARAMS (meth_obj), NULL);
  431.     if (METHALLKEYS (meth_obj)) {
  432.         warning ("All Keys specified", NULL);
  433.     }
  434.     warning (" Required return values", METHREQVALUES (meth_obj), NULL);
  435.     warning (" Rest return value type", METHRESTVALUES (meth_obj), NULL);
  436.     }
  437. }
  438.  
  439. static Object
  440. create_generic_parameters (Object params)
  441. {
  442.     Object entry, gf_params;
  443.  
  444.     gf_params = make_empty_list ();
  445.  
  446.     /* first get required params */
  447.     while (PAIRP (params)) {    /* CONTAINS BREAK! */
  448.     entry = CAR (params);
  449.  
  450.     if (entry == hash_rest_symbol) {    /* skip #rest */
  451.         params = CDR (params);
  452.         if (PAIRP (params)) {
  453.         params = CDR (params);
  454.         } else {
  455.         error ("method #rest designator not followed by a parameter", NULL);
  456.         }
  457.         break;
  458.     }
  459.     /* don't convert #key or #value */
  460.     if (entry == key_symbol || entry == hash_values_symbol) {
  461.         break;
  462.     }
  463.     if (PAIRP (entry)) {
  464.         entry = CAR (entry);
  465.     }
  466.     gf_params = append (gf_params, listem (entry, NULL));
  467.  
  468.     params = CDR (params);
  469.     }
  470.  
  471.     /* next add generic rest parameter */
  472.     gf_params = append (gf_params, listem (hash_rest_symbol, NULL));
  473.     gf_params = append (gf_params, listem (x_symbol, NULL));
  474.  
  475.     /* I believe that all other parts of the generic function parameters
  476.        ** should be the same as the initial method's
  477.      */
  478.     if (PAIRP (params)) {
  479.     gf_params = append (gf_params, params);
  480.     }
  481.     return (gf_params);
  482. }
  483.  
  484. Object
  485. make_method (Object name, Object params, Object body, struct frame *env, int do_generic)
  486. {
  487.     Object obj, gf;
  488.  
  489.     obj = allocate_object (sizeof (struct method));
  490.  
  491.     METHTYPE (obj) = Method;
  492.     if (name) {
  493.     METHNAME (obj) = name;
  494.     } else {
  495.     METHNAME (obj) = NULL;
  496.     }
  497.     parse_method_parameters (obj, params);
  498.     METHBODY (obj) = body;
  499.     METHENV (obj) = env;
  500.     if (do_generic && name) {
  501.     gf = symbol_value (name);
  502.     if (!gf) {
  503.         gf = make_generic_function (name,
  504.                     create_generic_parameters (params),
  505.                     make_empty_list ());
  506.         add_top_level_binding (name, gf, 0);
  507.     }
  508.     add_method (gf, obj);
  509.     return (gf);
  510.     } else {
  511.     return (obj);
  512.     }
  513. }
  514.  
  515. Object
  516. make_next_method (Object rest_methods, Object args)
  517. {
  518.     Object obj;
  519.  
  520.     obj = allocate_object (sizeof (struct next_method));
  521.  
  522.     NMTYPE (obj) = NextMethod;
  523.     NMREST (obj) = rest_methods;
  524.     NMARGS (obj) = args;
  525.     return (obj);
  526. }
  527.  
  528. static Object
  529. generic_function_make (Object arglist)
  530. {
  531.     Object obj;
  532.     Object required, rest, key, allkeys;
  533.     Object ptr;
  534.  
  535.     required = FIRST (arglist);
  536.     arglist = CDR (arglist);
  537.     rest = FIRST (arglist);
  538.     arglist = CDR (arglist);
  539.     key = FIRST (arglist);
  540.     arglist = CDR (arglist);
  541.     allkeys = FIRST (arglist);
  542.  
  543.     for (ptr = required; PAIRP (ptr); ptr = CDR (ptr)) {
  544.     if (!CLASSP (CAR (ptr))) {
  545.         error ("make: generic function specializer is not a class",
  546.            CAR (ptr),
  547.            NULL);
  548.     } else {
  549.         CAR (ptr) = listem (unspecified_object, CAR (ptr), NULL);
  550.     }
  551.     }
  552.  
  553.     obj = allocate_object (sizeof (struct generic_function));
  554.  
  555.     GFTYPE (obj) = GenericFunction;
  556.     GFNAME (obj) = unspecified_object;
  557.     GFREQPARAMS (obj) = required;
  558.  
  559.     if (rest != false_object) {
  560.     GFRESTPARAM (obj) = rest;
  561.     } else {
  562.     GFRESTPARAM (obj) = NULL;
  563.     }
  564.     GFKEYPARAMS (obj) = key;
  565.     if (allkeys == false_object) {
  566.     GFPROPS (obj) &= !GFALLKEYSMASK;
  567.     } else {
  568.     GFPROPS (obj) |= GFALLKEYSMASK;
  569.     }
  570.     GFMETHODS (obj) = make_empty_list ();
  571.     return (obj);
  572.  
  573. }
  574.  
  575. Object
  576. make_generic_function_driver (Object args)
  577. {
  578.     error ("make: not implemented for generic functions", NULL);
  579. }
  580.  
  581. /* local functions */
  582.  
  583. /* compare specializer lists s1 and s2 to see if each specializer in s1
  584.  * is a subclass of the corresponding specializer in s2
  585.  * list lengths are also compared.
  586.  */
  587. static int
  588. sub_specializers (Object s1, Object s2)
  589. {
  590.     while (!NULLP (s1) && !NULLP (s2)) {
  591.     if (!subtype (CAR (s1), CAR (s2))) {
  592.         return (0);
  593.     }
  594.     s1 = CDR (s1);
  595.     s2 = CDR (s2);
  596.     }
  597.  
  598.     if (!NULLP (s1) || !NULLP (s2))
  599.     return (0);
  600.  
  601.     return (1);
  602. }
  603.  
  604. /* add a method, replacing one with matching parameters
  605.  * if it's already there
  606.  */
  607. Object
  608. add_method (Object generic, Object method)
  609. {
  610.     Object new_specs, old_specs, methods, last, old_method;
  611.  
  612.     new_specs = function_specializers (method);
  613.  
  614. /* check method for fit with generic specializers
  615.  */
  616.     old_specs = function_specializers (generic);
  617.  
  618.     if (!sub_specializers (new_specs, old_specs)) {
  619.     error ("add-method: method specializers must be subtypes of generic func. specs.", method, NULL);
  620.     }
  621.     if (!GFRESTPARAM (generic) && METHRESTPARAM (method)) {
  622.     error ("add-method: generic must have #rest parameters if method does",
  623.            method,
  624.            NULL);
  625.     }
  626.     methods = GFMETHODS (generic);
  627.     last = NULL;
  628.     while (!NULLP (methods)) {
  629.     old_specs = function_specializers (CAR (methods));
  630.     if (same_specializers (new_specs, old_specs)) {
  631.         old_method = CAR (methods);
  632.         if (!last) {
  633.         GFMETHODS (generic) = cons (method, CDR (methods));
  634.         return (construct_values (2, method, old_method));
  635.         } else {
  636.         CDR (last) = cons (method, CDR (methods));
  637.         return (construct_values (2, method, old_method));
  638.         }
  639.     }
  640.     last = methods;
  641.     methods = CDR (methods);
  642.     }
  643.     GFMETHODS (generic) = cons (method, GFMETHODS (generic));
  644.     return (construct_values (2, method, false_object));
  645. }
  646.  
  647. static Object
  648. generic_function_methods (Object gen)
  649. {
  650.     if (!GFUNP (gen)) {
  651.     error ("generic-function-methods: argument must be a generic function", gen, NULL);
  652.     }
  653.     return (GFMETHODS (gen));
  654. }
  655.  
  656. static Object
  657. generic_function_mandatory_keywords (Object generic)
  658. {
  659.     return (GFKEYPARAMS (generic));
  660. }
  661.  
  662. static Object
  663. function_specializers (Object func)
  664. {
  665.     Object params;
  666.  
  667.     if (METHODP (func)) {
  668.     params = METHREQPARAMS (func);
  669.     } else if (GFUNP (func)) {
  670.     params = GFREQPARAMS (func);
  671.     } else {
  672.     error ("function-specializers: arg. must be a method or generic function",
  673.            func,
  674.            NULL);
  675.     }
  676.     return make_specializers_from_params (params);
  677. }
  678.  
  679. static Object
  680. function_values (Object func)
  681. {
  682.     Object vals, rest;
  683.  
  684.     if (METHODP (func)) {
  685.     vals = METHREQVALUES (func);
  686.     rest = METHRESTVALUES (func);
  687.     } else if (GFUNP (func)) {
  688.     vals = GFREQVALUES (func);
  689.     rest = GFRESTVALUES (func);
  690.     } else {
  691.     error ("function-values: arg. must be a method or generic function",
  692.            func,
  693.            NULL);
  694.     }
  695.     return construct_values (2,
  696.                  vals,
  697.                  rest == NULL ? false_object : rest);
  698.  
  699. }
  700.  
  701. static Object
  702. make_specializers_from_params (Object params)
  703. {
  704.     Object specs, *tmp_ptr;
  705.  
  706.     for (specs = make_empty_list (), tmp_ptr = &specs;
  707.      PAIRP (params);
  708.      tmp_ptr = &CDR (*tmp_ptr), params = CDR (params)) {
  709.     *tmp_ptr = cons (SECOND (CAR (params)), make_empty_list ());
  710.  
  711.     }
  712.     return (specs);
  713.  
  714. }
  715.  
  716. /* 
  717.    returns three values:
  718.    1) number of required parameters
  719.    2) #t if takes rest, #f otherwise
  720.    3) sequence of keywords or #f if no keywords
  721.  */
  722.  
  723. static Object
  724. function_arguments (Object fun)
  725. {
  726.     Object params, obj, keywords;
  727.     Object has_rest;
  728.  
  729.     switch (POINTERTYPE (fun)) {
  730.     case GenericFunction:
  731.     params = GFREQPARAMS (fun);
  732.     if (GFALLKEYS (fun)) {
  733.         keywords = all_symbol;
  734.     } else {
  735.         keywords = GFKEYPARAMS (fun);
  736.     }
  737.     if (GFRESTPARAM (fun)) {
  738.         has_rest = true_object;
  739.     } else {
  740.         has_rest = false_object;
  741.     }
  742.     break;
  743.     case Method:
  744.     params = METHREQPARAMS (fun);
  745.     if (METHALLKEYS (fun)) {
  746.         keywords = all_symbol;
  747.     } else {
  748.         keywords = METHKEYPARAMS (fun);
  749.     }
  750.     if (METHRESTPARAM (fun)) {
  751.         has_rest = true_object;
  752.     } else {
  753.         has_rest = false_object;
  754.     }
  755.     break;
  756.     case Primitive:
  757.     error ("function-arguments: cannot query arguments of a primitive", fun, NULL);
  758.     default:
  759.     error ("function-arguments: bad argument", fun, NULL);
  760.     }
  761.     return (construct_values (3, list_length_int (params), has_rest, keywords));
  762. }
  763.  
  764. static int
  765. find_keyword_in_list (Object keyword, Object keyword_list)
  766. {
  767.     if (keyword_list == all_symbol) {
  768.     return 1;
  769.     } else {
  770.     while (PAIRP (keyword_list)) {
  771.         if (keyword == CAR (CAR (keyword_list))) {
  772.         return 1;
  773.         }
  774.         keyword_list = CDR (keyword_list);
  775.     }
  776.     }
  777.     return 0;
  778. }
  779.  
  780. static Object
  781. user_applicable_method_p (Object argfun, Object sample_args)
  782. {
  783.     applicable_method_p (argfun, sample_args, 1);
  784. }
  785.  
  786. /*
  787.  * In applicable_method_p, strict_check is true if we should complain
  788.  * about extra keyword arguments.  It should be set to 0 for internal
  789.  * tests for generic function dispatch, etc.
  790.  */
  791. static Object
  792. applicable_method_p (Object argfun, Object sample_args, int strict_check)
  793. {
  794.     Object args, specs, samples, theargs, keywords, sample_keys;
  795.     int num_required, i, no_rest_param, check_keywords = 1;
  796.     Object funs, fun;
  797.  
  798.     if (!METHODP (argfun) && !GFUNP (argfun)) {
  799.     error ("applicable-method?: first argument must be a generic function or method", fun, NULL);
  800.     }
  801.     if (METHODP (argfun)) {
  802.     funs = cons (argfun, make_empty_list ());
  803.     } else {
  804.     strict_check = 0;
  805.     funs = argfun;
  806.     }
  807.  
  808.     while (PAIRP (funs)) {
  809.     fun = CAR (funs);
  810.     funs = CDR (funs);
  811.     args = function_arguments (fun);
  812.     specs = function_specializers (fun);
  813.  
  814.     /* Are there more sample args than required args?
  815.      */
  816.     num_required = INTVAL (FIRSTVAL (args));
  817.     if (list_length (sample_args) < num_required) {
  818.         return (false_object);
  819.     }
  820.     /* Do the types of the required args match the
  821.        types of the sample args?
  822.      */
  823.     samples = sample_args;
  824.     for (i = 0; i < num_required; ++i) {
  825.         if (!instance (CAR (samples), CAR (specs))) {
  826.         return (false_object);
  827.         }
  828.         samples = CDR (samples);
  829.         specs = CDR (specs);
  830.     }
  831.  
  832.     if (PAIRP (samples)) {
  833.         keywords = THIRDVAL (args);
  834.         /* If the method accepts keywords, make sure supplied keywords match */
  835.         if (PAIRP (keywords) || keywords == all_symbol) {
  836.         if (keywords == all_symbol) {
  837.             check_keywords = 0;
  838.         }
  839.         /* If keywords != all_symbol, make sure rest of sample_args
  840.          * are keyword specified, and that all keywords
  841.          * in sample_args are in the keyword list
  842.          */
  843.         while (PAIRP (samples)) {
  844.             if (!KEYWORDP (CAR (samples)) || EMPTYLISTP (CDR (samples))) {
  845.             /* Has non keyword where our method needs one */
  846.             return (false_object);
  847.             } else if (check_keywords) {
  848.             if (strict_check &&
  849.               !find_keyword_in_list (CAR (samples), keywords)) {
  850.                 /* Has a keyword not in the method */
  851.                 return (false_object);
  852.             }
  853.             }
  854.             samples = CDR (CDR (samples));
  855.         }
  856.         } else if (SECONDVAL (args) == false_object) {
  857.         /* We have no rest parameter.  If there are more arguments, this
  858.          * ain't a match.
  859.          */
  860.         return (false_object);
  861.         }
  862.     }
  863.     }
  864.  
  865.     /* We passed all of the tests.
  866.      */
  867.     return (true_object);
  868. }
  869.  
  870. Object
  871. sorted_applicable_methods (Object fun, Object sample_args)
  872. {
  873.     Object methods, app_methods, sorted_methods, method;
  874.  
  875.     methods = GFMETHODS (fun);
  876.     app_methods = make_empty_list ();
  877.     while (!NULLP (methods)) {
  878.     method = CAR (methods);
  879.     if (applicable_method_p (method, sample_args, 0) != false_object) {
  880.         app_methods = cons (method, app_methods);
  881.     }
  882.     methods = CDR (methods);
  883.     }
  884.     if (NULLP (app_methods)) {
  885.     return error ("no applicable methods", fun, sample_args, NULL);
  886.     }
  887.     return sort_methods (app_methods, sample_args);
  888. }
  889.  
  890. /* See KLUDGE ALERT below */
  891. Object sort_driver_args____;
  892.  
  893. static Object
  894. sort_methods (Object methods, Object sample_args)
  895. {
  896.     Object method_vector;
  897.     Object *prev_ptr, next;
  898.     typedef int (*sortfun) ();
  899.  
  900.     /* KLUDGE ALERT!! Due to lack of closures in C, the following
  901.      * is included as a public service to code readers.
  902.      * We need the comparator for the sort to know about the
  903.      * sample arguments.  These are stored in the static global
  904.      * sort_driver_args____.
  905.      */
  906.     sort_driver_args____ = sample_args;
  907.  
  908.     if (PAIRP (CDR (methods))) {
  909.     method_vector = make_sov (methods);
  910.     qsort (SOVELS (method_vector),
  911.            SOVSIZE (method_vector),
  912.            sizeof (Object),
  913.              (sortfun) sort_driver);
  914.  
  915.     methods = vector_to_list (method_vector);
  916.     }
  917.     for (prev_ptr = &methods, next = CDR (methods);
  918.      PAIRP (next);
  919.      prev_ptr = &CDR (*prev_ptr), next = CDR (next)) {
  920.     if (specializer_compare (function_specializers (CAR (*prev_ptr)),
  921.                  function_specializers (CAR (next))) == 0) {
  922.         next = *prev_ptr;
  923.         *prev_ptr = make_empty_list ();
  924.         break;
  925.     }
  926.     }
  927.     return construct_values (2, methods, next);
  928. }
  929.  
  930. static int
  931. sort_driver (Object *pmeth1, Object *pmeth2)
  932. {
  933.     Object specs1, specs2;
  934.     int value;
  935.  
  936.     specs1 = function_specializers (*pmeth1);
  937.     specs2 = function_specializers (*pmeth2);
  938.     return specializer_compare (specs1, specs2);
  939. }
  940.  
  941. /* It is assumed that s1 and s2 have the same length.
  942.  */
  943. static int
  944. same_specializers (Object s1, Object s2)
  945. {
  946.     while (!NULLP (s1) && !NULLP (s2)) {
  947.     if (same_class_p (CAR (s1), CAR (s2)) == false_object) {
  948.         return (0);
  949.     }
  950.     s1 = CDR (s1);
  951.     s2 = CDR (s2);
  952.     }
  953.     if (!NULLP (s1) || !NULLP (s2))
  954.     return (0);
  955.     return (1);
  956. }
  957.  
  958. static int
  959. specializer_compare (Object s1, Object s2)
  960. {
  961.     Object spec1, spec2, arg, specs1, specs2, args, class_list;
  962.     int ret = 0;
  963.  
  964.     specs1 = s1;
  965.     specs2 = s2;
  966.     args = sort_driver_args____;
  967.  
  968.     while (!NULLP (specs1)) {
  969.     spec1 = CAR (specs1);
  970.     spec2 = CAR (specs2);
  971.     arg = CAR (args);
  972.  
  973.     if (spec1 == spec2) {
  974.         /* No help from this specializer */
  975.     } else if (subtype (spec1, spec2)) {
  976.         /* This suggests less than */
  977.         if (ret <= 0) {
  978.         ret = -1;
  979.         } else {
  980.         /*
  981.          * We previously saw an indication of greater than.
  982.          * Thus, these two methods are unordered!
  983.          */
  984.         return 0;
  985.         }
  986.     } else if (subtype (spec2, spec1)) {
  987.         /* This suggests greater than */
  988.         if (ret >= 0) {
  989.         ret = 1;
  990.         } else {
  991.         /* We previously saw an indication of less than. */
  992.         return 0;
  993.         }
  994.     } else if (CLASSP (spec1) && CLASSP (spec2)) {
  995.         for (class_list = CLASSPRECLIST (objectclass (arg));
  996.          PAIRP (class_list);
  997.          class_list = CDR (class_list)) {
  998.         if (spec1 == CAR (class_list)) {
  999.             if (ret <= 0) {
  1000.             ret = -1;
  1001.             break;
  1002.             } else {
  1003.             return 0;
  1004.             }
  1005.         } else if (spec2 == CAR (class_list)) {
  1006.             if (ret >= 0) {
  1007.             ret = 1;
  1008.             break;
  1009.             } else {
  1010.             return 0;
  1011.             }
  1012.         }
  1013.         }
  1014.     } else if (instance (arg, spec1)
  1015.            && instance (arg, spec2)
  1016.            && (!subtype (spec1, spec2))
  1017.            && (!subtype (spec2, spec1))) {
  1018.         /* These are ambiguous according to Design Note 8 */
  1019.         return 0;
  1020.     }
  1021.     specs1 = CDR (specs1);
  1022.     specs2 = CDR (specs2);
  1023.     args = CDR (args);
  1024.     }
  1025.     return ret;
  1026. }
  1027.  
  1028. static Object
  1029. find_method (Object generic, Object spec_list)
  1030. {
  1031.     Object methods, specs1, specs2;
  1032.  
  1033.     for (methods = GFMETHODS (generic);
  1034.      PAIRP (methods);
  1035.      methods = CDR (methods)) {
  1036.     if (same_specializers (function_specializers (CAR (methods)),
  1037.                    spec_list)) {
  1038.         return CAR (methods);
  1039.     }
  1040.     }
  1041.     return false_object;
  1042. }
  1043.  
  1044. static Object
  1045. remove_method (Object generic, Object method)
  1046. {
  1047.     Object *tmp_ptr;
  1048.  
  1049.     for (tmp_ptr = &GFMETHODS (generic);
  1050.      PAIRP (*tmp_ptr);
  1051.      tmp_ptr = &CDR (*tmp_ptr)) {
  1052.     /* need to add test for sealed function, when available */
  1053.     if (method == CAR (*tmp_ptr)) {
  1054.         *tmp_ptr = CDR (*tmp_ptr);
  1055.         return method;
  1056.     }
  1057.     }
  1058.     error ("remove-method: generic function does not contain method",
  1059.        generic, method, NULL);
  1060. }
  1061.  
  1062. static Object
  1063. debug_name_setter (Object method, Object name)
  1064. {
  1065.     METHNAME (method) = name;
  1066.     return (name);
  1067. }
  1068.